home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b2uni.c < prev    next >
C/C++ Source or Header  |  1988-11-24  |  10KB  |  390 lines
  1. /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
  2.  
  3. /*
  4.   $Header: b2uni.c,v 1.4 85/08/22 16:57:24 timo Exp $
  5. */
  6.  
  7. #include "b.h"
  8. #include "b0fea.h"
  9. #include "b1obj.h"
  10. #include "b2par.h"
  11. #include "b2key.h"
  12. #include "b2syn.h"
  13. #include "b2nod.h"
  14. #include "b3env.h"
  15. #include "b3err.h"
  16. #include "b3sou.h" /* for permkey() */
  17.  
  18. /* ******************************************************************** */
  19. /*        unit                            */
  20. /* ******************************************************************** */
  21.  
  22. Visible bool unit_keyword() {
  23.     bool b; txptr tx0= tx;
  24.     b= how_to_keyword() || yield_keyword() || test_keyword();
  25.     tx= tx0;
  26.     return b;
  27. }
  28.  
  29. Hidden value formlist, sharelist;
  30. Hidden envtab reftab; 
  31. Visible literal idf_cntxt;
  32.  
  33. Forward bool is_howto_unit(), is_yield_unit(), is_test_unit();
  34. Forward parsetree unicmd_suite(), ref_suite();
  35.  
  36. Visible parsetree unit(heading) bool heading; {
  37.     parsetree v= NilTree;
  38.     if (!heading) {
  39.         lino= 1;
  40.         cntxt= In_unit;
  41.         release(uname); uname= Vnil;
  42.     }
  43.     if (!is_howto_unit(&v, heading) &&
  44.         !is_yield_unit(&v, heading) &&
  45.         !is_test_unit(&v, heading)
  46.        )
  47.         parerr(MESS(2800, "no unit keyword where expected"));
  48. #ifdef TYPE_CHECK
  49.     if (!heading) type_check(v);
  50. #endif
  51.     return v;
  52. }
  53.  
  54. /* ******************************************************************** */
  55. /*        howto_unit                        */
  56. /* ******************************************************************** */
  57.  
  58. Forward value hu_formals();
  59.  
  60. Hidden bool is_howto_unit(v, heading) parsetree *v; bool heading; {
  61.     if (how_to_keyword()) {
  62.         value kw, w, f;
  63.         txptr ftx, ttx;
  64.         if (cur_ilev != 0) parerr(MESS(2801, "unit starts with indentation"));
  65.         formlist= mk_elt(); 
  66.         skipsp(&tx);
  67.         kw= keyword(); 
  68.         release(uname); uname= permkey(kw, How);
  69.         if (in(kw, kwlist)) pprerr2(kw, MESS(2802, " is a reserved keyword"));
  70.         req(":", ceol, &ftx, &ttx);
  71.         idf_cntxt= In_formal;
  72.         f= hu_formals(ftx, kw); tx= ttx;
  73.         if (!is_comment(&w)) w= Vnil;
  74.         *v= node8(HOW_TO, copy(kw), f, w, NilTree, NilTree, Vnil, Vnil);
  75.         if (!heading) {
  76.             sharelist= mk_elt();
  77.             *Branch(*v, HOW_SUITE)= unicmd_suite();
  78.             reftab= mk_elt();
  79.             *Branch(*v, HOW_REFINEMENT)= ref_suite();
  80.             *Branch(*v, HOW_R_NAMES)= reftab;
  81.             release(sharelist);
  82.         }
  83.         release(formlist); 
  84.         return Yes;
  85.     }
  86.     return No;
  87. }
  88.  
  89. Hidden value hu_formals(q, kw) txptr q; value kw; {
  90.     value t, v, w;
  91.     skipsp(&tx);
  92.     if (Text(q) && is_tag(&t)) treat_idf(t);
  93.     else t= Vnil;
  94.     skipsp(&tx);
  95.     v= Text(q) ? hu_formals(q, keyword()) : Vnil;
  96.     w= node4(FORMAL, kw, t, v);
  97.     return w;
  98. }
  99.  
  100. /* ******************************************************************** */
  101. /*        yield_unit                        */
  102. /* ******************************************************************** */
  103.  
  104. Forward parsetree ytu_formals();
  105.  
  106. Hidden bool is_yield_unit(v, heading) parsetree *v; bool heading; {
  107.     if (yield_keyword()) {
  108.         parsetree f; value name, w, adicity;
  109.         txptr ftx, ttx;
  110.         if (cur_ilev != 0) parerr(MESS(2803, "unit starts with indentation"));
  111.         formlist= mk_elt(); 
  112.         skipsp(&tx);
  113.         req(":", ceol, &ftx, &ttx);
  114.         f= ytu_formals(ftx, 'y', &name, &adicity); tx= ttx;
  115.         if (!is_comment(&w)) w= Vnil;
  116.         *v= node9(YIELD, copy(name), adicity, f, w, NilTree,
  117.               NilTree, Vnil, Vnil);
  118.         if (!heading) {
  119.             sharelist= mk_elt();
  120.             *Branch(*v, FPR_SUITE)= unicmd_suite();
  121.             reftab= mk_elt();
  122.             *Branch(*v, FPR_REFINEMENT)= ref_suite();
  123.             *Branch(*v, FPR_R_NAMES)= reftab;
  124.             release(sharelist);
  125.         }
  126.         release(formlist); 
  127.         return Yes;
  128.     }
  129.     return No;
  130. }
  131.  
  132. /* ******************************************************************** */
  133. /*        test_unit                        */
  134. /* ******************************************************************** */
  135.  
  136. Hidden bool is_test_unit(v, heading) parsetree *v; bool heading; {
  137.     if (test_keyword()) {
  138.         parsetree f; value name, w, adicity;
  139.         txptr ftx, ttx;
  140.         if (cur_ilev != 0) parerr(MESS(2804, "unit starts with indentation"));
  141.         formlist= mk_elt();
  142.         skipsp(&tx);
  143.         req(":", ceol, &ftx, &ttx);
  144.         f= ytu_formals(ftx, 't', &name, &adicity); tx= ttx;
  145.         if (!is_comment(&w)) w= Vnil;
  146.         *v= node9(TEST, copy(name), adicity, f, w, NilTree,
  147.               NilTree, Vnil, Vnil);
  148.         if (!heading) {
  149.             sharelist= mk_elt();
  150.             *Branch(*v, FPR_SUITE)= unicmd_suite();
  151.             reftab= mk_elt();
  152.             *Branch(*v, FPR_REFINEMENT)= ref_suite();
  153.             *Branch(*v, FPR_R_NAMES)= reftab;
  154.             release(sharelist);
  155.         }
  156.         release(formlist); 
  157.         return Yes;
  158.     }
  159.     return No;
  160. }
  161.  
  162. /* ******************************************************************** */
  163.  
  164. #define FML_IN_FML MESS(2805, " is already a formal parameter or operand")
  165. #define SH_IN_FML  MESS(2806, " is already a formal parameter")
  166. #define SH_IN_SH   MESS(2807, " is already a shared identifier")
  167. #define REF_IN_FML MESS(2808, " is already a formal parameter")
  168. #define REF_IN_SH  MESS(2809, " is already a shared identifier")
  169. #define REF_IN_REF MESS(2810, " is already a refinement name")
  170.  
  171. Hidden Procedure treat_idf(t) value t; {
  172.     switch (idf_cntxt) {
  173.         case In_formal:    if (in(t, formlist)) pprerr2(t, FML_IN_FML);
  174.                 insert(t, &formlist);
  175.                 break;
  176.         case In_share:    if (in(t, formlist)) pprerr2(t, SH_IN_FML);
  177.                 if (in(t, sharelist)) pprerr2(t, SH_IN_SH);
  178.                 insert(t, &sharelist);
  179.                 break;
  180.         case In_ref:    if (in(t, formlist)) pprerr2(t, REF_IN_FML);
  181.                 if (in(t, sharelist)) pprerr2(t, REF_IN_SH);
  182.                 break;
  183.         case In_ranger: break;
  184.         default:    break;
  185.     }
  186. }
  187.  
  188. Forward parsetree fml_operand();
  189.  
  190. Hidden parsetree ytu_formals(q, yt, name, adic)
  191.     txptr q; char yt; value *name, *adic; {
  192.  
  193.     parsetree v1, v2, v3;
  194.     *name= Vnil;
  195.     idf_cntxt= In_formal;
  196.     v1= fml_operand(q);
  197.     skipsp(&tx);
  198.     if (!Text(q)) { /* zeroadic */
  199.         *adic= zero; 
  200.         if (nodetype(v1) == TAG) {
  201.             *name= *Branch(v1, TAG_NAME);
  202.             release(uname); uname= permkey(*name, Zer);
  203.          } else
  204.             pprerr(MESS(2811, "user defined functions must be tags"));
  205.         return v1;
  206.     }
  207.  
  208.     v2= fml_operand(q);
  209.     skipsp(&tx);
  210.     if (!Text(q)) { /* monadic */
  211.         *adic= one; 
  212.         if (nodetype(v1) == TAG) {
  213.             *name= *Branch(v1, TAG_NAME);
  214.             release(uname); uname= permkey(*name, Mon);
  215.         } else
  216.             pprerr(MESS(2812, "no monadic function name"));
  217.         if (nodetype(v2) == TAG) treat_idf(*Branch(v2, TAG_NAME));
  218.         return node4(yt == 'y' ? MONF : MONPRD, *name, v2, Vnil);
  219.     }
  220.  
  221.     v3= fml_operand(q);
  222.     /* dyadic */
  223.     *adic= mk_integer(2);
  224.     if (nodetype(v2) == TAG) {
  225.         *name= *Branch(v2, TAG_NAME);
  226.         release(uname); uname= permkey(*name, Dya);
  227.     } else
  228.         pprerr(MESS(2813, "no dyadic function name"));
  229.     upto(q, "dyadic formal formula");
  230.     if (nodetype(v1) == TAG) treat_idf(*Branch(v1, TAG_NAME));
  231.     if (nodetype(v3) == TAG) treat_idf(*Branch(v3, TAG_NAME));
  232.     return node5(yt == 'y' ? DYAF : DYAPRD, v1, *name, v3, Vnil);
  233. }
  234.  
  235. Hidden parsetree fml_operand(q) txptr q; {
  236.     value t;
  237.     skipsp(&tx);
  238.     if (nothing(q, "formal operand")) return NilTree;
  239.     else if (is_tag(&t)) return node2(TAG, t);
  240.     else if (open_sign()) return compound(q, idf);
  241.     else {
  242.         parerr(MESS(2814, "no formal operand where expected"));
  243.         tx= q;
  244.         return NilTree;
  245.     }
  246. }
  247.  
  248. /* ******************************************************************** */
  249. /*        unit_command_suite                    */
  250. /* ******************************************************************** */
  251.  
  252. Forward parsetree ucmd_seq();
  253.  
  254. Forward bool share();
  255.  
  256. Hidden parsetree unicmd_suite() {
  257.     if (ateol()) 
  258.         return ucmd_seq(0, Yes);
  259.     else {
  260.         parsetree v; value c; intlet l= lino;
  261.         suite_command(&v, &c);
  262.         return node5(SUITE, mk_integer(l), v, c, NilTree);
  263.     }
  264. }
  265.  
  266. Hidden parsetree ucmd_seq(cil, first) intlet cil; bool first; {
  267.     value c; intlet level, l;
  268.     level= ilev(); l= lino;
  269.     if (is_comment(&c)) 
  270.         return node5(SUITE, mk_integer(l), NilTree, c,
  271.                 ucmd_seq(cil, first));
  272.     if ((level == cil && !first) || (level > cil && first)) {
  273.         parsetree v;
  274.         findceol();
  275.         if (share(ceol, &v, &c)) 
  276.             return node5(SUITE, mk_integer(l), v, c,
  277.                     ucmd_seq(level, No));
  278.         veli();
  279.         return cmd_suite(cil, first);
  280.     }
  281.     veli();
  282.     return NilTree;
  283. } 
  284.  
  285. Hidden bool share(q, v, c) txptr q; parsetree *v; value *c; {
  286.     if (share_keyword()) {
  287.         idf_cntxt= In_share;
  288.         *v= node2(SHARE, idf(q));
  289.         *c= tail_line();
  290.         return Yes;
  291.     }
  292.     return No;
  293. }
  294.  
  295.  
  296. /* ******************************************************************** */
  297. /*        refinement_suite                    */
  298. /* ******************************************************************** */
  299.  
  300. Hidden parsetree ref_suite() {
  301.     value name; bool t;
  302.     if (ilev() > 0) {
  303.         parerr(MESS(2815, "indentation where not allowed"));
  304.         return NilTree;
  305.     }
  306.     if ((t= is_tag(&name)) || is_keyword(&name)) {
  307.         parsetree v, s; value w, *aa, r;
  308.         skipsp(&tx);
  309.         if (Char(tx) != ':') {
  310.             release(name);
  311.             tx= fcol();
  312.             veli(); return NilTree;
  313.         }
  314.         /* lino= 1; cntxt= In_ref; */
  315.         tx++;
  316.         if (t) {
  317.             idf_cntxt= In_ref;
  318.             treat_idf(name);
  319.         }
  320.         if (in_env(reftab, name, &aa)) pprerr2(name, REF_IN_REF);
  321.         findceol();
  322.         if (!is_comment(&w)) w= Vnil;
  323.         s= cmd_suite(0, Yes);
  324.         v= node6(REFINEMENT, name, w, s, Vnil, Vnil);
  325.         e_replace(r= mk_ref(v), &reftab, name);
  326.         release(r);
  327.         *Branch(v, REF_NEXT)= ref_suite();
  328.         return v;
  329.     } 
  330.     veli();
  331.     return NilTree;
  332. }
  333.  
  334. /* ******************************************************************** */
  335. /*        collateral, compound                    */
  336. /* ******************************************************************** */
  337.  
  338. Hidden parsetree n_collateral(q, n, base)
  339.     txptr q; intlet n; parsetree (*base)(); {
  340.  
  341.     parsetree v, w; txptr ftx, ttx;
  342.     if (find(",", q, &ftx, &ttx)) {
  343.         w= (*base)(ftx); tx= ttx;
  344.         v= n_collateral(q, n+1, base);
  345.     } else {
  346.         w= (*base)(q);
  347.         if (n == 1) return w;
  348.         v= mk_compound(n);
  349.     }
  350.     *Field(v, n-1)= w;
  351.     return n > 1 ? v : node2(COLLATERAL, v);
  352. }
  353.  
  354. Visible parsetree collateral(q, base) txptr q; parsetree (*base)(); {
  355.     return n_collateral(q, 1, base);
  356. }
  357.  
  358. Visible parsetree compound(q, base) txptr q; parsetree (*base)(); {
  359.     parsetree v; txptr ftx, ttx;
  360.     req(")", q, &ftx, &ttx);
  361.     v= (*base)(ftx); tx= ttx;
  362.     return node2(COMPOUND, v);
  363. }
  364.  
  365. /* ******************************************************************** */
  366. /*        idf, singidf                        */
  367. /* ******************************************************************** */
  368.  
  369. Hidden parsetree singidf(q) txptr q; {
  370.     parsetree v;
  371.     skipsp(&tx);
  372.     if (nothing(q, "identifier"))
  373.         v= NilTree;
  374.     else if (open_sign())
  375.         v= compound(q, idf);
  376.     else if (is_tag(&v)) {
  377.         treat_idf(v);
  378.         v= node2(TAG, v);
  379.     } else {
  380.         parerr(MESS(2816, "no identifier where expected"));
  381.         v= NilTree;
  382.     }
  383.     upto(q, "identifier");
  384.     return v;
  385. }
  386.  
  387. Visible parsetree idf(q) txptr q; {
  388.     return collateral(q, singidf);
  389. }
  390.